#!/usr/bin/perl
use strict;
use warnings;
use Language::Prolog::Yaswi qw(:load :query);
use Language::Prolog::Sugar
  functors => [qw(text link parent child tag url target only)],
  vars     => [qw(X A B C D E)];
use YAML;
use Heap::Simple;

my $config_file = shift || 'config';
our %params = %{YAML::LoadFile($config_file)};

our $max_rules_cnt = $params{max_rules_cnt};
our $min_accuracy  = $params{min_accuracy};
our $max_variable  = 'A';
$max_variable++ for 1..($params{max_depth});

my $hash_root = {};
my %tokens = %{YAML::LoadFile($params{tokens_file})};
foreach my $token (keys %tokens) {
    my @sub_tokens = split /\s+/, $token;
    push @sub_tokens, 'DATA';
    my $code = '$hash_root->{\''.join("'}{'", @sub_tokens)."'} = '$token';"; 
    eval $code;
    die "$@" if $@;
}
#unlink $params{tokens_file};

our $root = &hash_to_array($hash_root->{'link:a'});
$hash_root = undef;

our @total_pos;
our @total_neg;

our @labels = @{YAML::LoadFile($params{labels_file})};
for (0..$#labels) {
    $labels[$_] eq '+' 
        ? push(@total_pos, $_)
        : push(@total_neg, $_);
}
#unlink $params{labels_file};

our $min_pos_cover = $params{min_pos_cover} * @total_pos;

print "Loading facts...\n";
swi_consult $params{facts_file};
print "Done!\n\n";
#unlink $params{facts_file};

print "Start inductive logic programming...\n\n";

our $frontier = Heap::Simple->new(elements => 'Any', order => '>');
$frontier->key_insert(0, ['link(X, A)', 'A', \@total_pos, \@total_neg, ['A', $root, 0 ] ]);

our @results;

our $event_loop = 1;

$SIG{QUIT} = sub {
    print "\n", '*' x 20, "\n";
    print "Frontier: ", $frontier->count, "\n";
    print "Result: ", scalar(@results), "\n";
    print_results(*STDOUT);
    print '*' x 20, "\n";
};

$SIG{INT} = sub {
    $event_loop = !$event_loop;
};

while ( $event_loop and $frontier->count > 0 ) {
    my $top_element = $frontier->extract_top;
	&print_rule($top_element);
    my ($rule, $last_variable, $pos_ref, $neg_ref, @entries) = @$top_element;
    unless (@results < $max_rules_cnt or get_h_value_from(scalar(@$pos_ref), scalar(@$pos_ref)) > get_h_value($results[$#results])) {
        print "prune\n"; 
        next;
    }
    for my $entry_index (0..$#entries) {
        my ($variable, $ref, $index, @children) = @{$entries[$entry_index]};
        print "\n  $variable";
        my $token = &get_token($ref, $index);
        for my $new_index (($index + 1)..$#{$ref}) {
            my $new_ref = $ref->[$new_index];
            my $new_token = &get_token($ref, $new_index);
            next if $token =~ /^only$/ and $new_token =~ /^text:/ or $token =~ /^text:/ and $new_token =~ /^only$/;
            next if $token =~ /^parent/ and $new_token =~ /^parent/;
            print "\n    $new_token";
            my ($new_rule, $new_last_variable, @new_pos, @new_neg);
            my @new_entries = @entries;
            my @new_children = @children;
            my ($pred, $constant) = split /:/, $new_token;
            if ($pred !~ /^(?:parent|child)$/) {
                $new_last_variable = $last_variable;
                if (defined $constant) {
                    $new_rule = "$rule, $pred($variable, $constant)";
                }
                else {
                    $new_rule = "$rule, $pred($variable)";
                    if ($pred eq 'target') {
                        $new_rule .= ", not(link(X, $variable))";
                    }
                }
            }
            else {
                ($new_last_variable = $last_variable)++;
                next if $new_last_variable gt $max_variable;
                my $literal = "$pred($variable, $new_last_variable, $constant)";
                if ($pred eq 'parent') {
                    push @new_entries, [$new_last_variable, $new_ref, 0, $variable];
                }
                elsif ($pred eq 'child') {
                    for my $child (@children) {
                        $literal .= ", $new_last_variable \\== $child";
                    }
                    push @new_children, $new_last_variable;
                    push @new_entries, [$new_last_variable, $new_ref, 0];
                }
                else {
                    die "unknown predicate: $pred\n";
                }
                $new_rule  = "$rule, $literal";
            }
            for (@$pos_ref) {
                push @new_pos, $_ if &cover($new_rule, $_);
            }
            next if @new_pos < $min_pos_cover;
            for (@$neg_ref) {
                push @new_neg, $_ if &cover($new_rule, $_);
            }
            next if $pred =~ /^(?:url|text)$/ and !&significant(scalar(@$pos_ref), scalar(@$neg_ref), scalar(@new_pos), scalar(@new_neg));
            $new_entries[$entry_index] = [$variable, $ref, $new_index, @new_children];
            my $new_rule_ref = [$new_rule, $new_last_variable, \@new_pos, \@new_neg, @new_entries];
            my $new_accuracy = @new_pos / (@new_pos + @new_neg);
            printf " (p: %d n: %d a: %.2f%%)", scalar(@new_pos), scalar(@new_neg), 100 * $new_accuracy;
            if ($new_accuracy > $min_accuracy) {
                if (can_insert($new_rule_ref, \@results)) {
                    insert($new_rule_ref, \@results);
                    print " R";
                }
                else {
                    print " P";
                }
            }
            $frontier->key_insert(get_priority(scalar(@new_pos), scalar(@new_neg)), $new_rule_ref);
            print " F";
        }
    }
    print "\n\n";
}

my %token_seen;
for my $result (@results) {
    for (@$result[4..$#{$result}]) {
        my $token = $_->[1][$_->[2]];
        $token = $token->[0] if $_->[2] != 0;
        $token_seen{$token} = 1;
    }
}

open DICT, "> $params{dict_file}" or die "$!";
print DICT 'link:a', "\n";
print DICT $_, "\n" for keys %token_seen;
close DICT;

open my $result_handler, "> $params{rules_file}" or die "$!";
print_results($result_handler);
close $result_handler;

print "All done!\n\n";

sub print_results {
    my $handler = shift;
    print $handler ":- dynamic text/2, link/2, parent/3, child/3, tag/2, url/2, target/1, only/1.\n";
    print $handler ":- style_check(-singleton).\n";
    for my $index (0..$#results) {
        my $result = $results[$index];
        my ($rule, undef, $pos_ref, $neg_ref) = @$result;
        printf $handler "rule$index(X) :- %s.\n%%pos: %d neg: %d a: %.2f%%\n\n", $rule, scalar(@$pos_ref), scalar(@$neg_ref), 100 * @$pos_ref / (@$pos_ref + @$neg_ref);
    }

    my @total_covers;
    my $N = @total_pos + @total_neg;
    for my $result (@results) {
        $total_covers[$_] = 1 for (@{$result->[2]}, @{$result->[3]});
    }
    my ($total_cover_cnt, $total_pos_cover_cnt) = (0, 0);
    $total_cover_cnt = grep { defined $_ } @total_covers;
    for (@total_pos) {
        $total_pos_cover_cnt++ if defined $total_covers[$_];
    }

    print $handler sprintf "%%Total coverage ratio: %.2f%% (%d/%d)\n", 100 * $total_cover_cnt / $N, $total_cover_cnt, $N;
    print $handler sprintf "%%Total pos coverage ratio: %.2f%% (%d/%d)\n", 100 * $total_pos_cover_cnt / @total_pos, $total_pos_cover_cnt, scalar(@total_pos);
}

sub cover {
    my ($query, $index) = @_;
    (my $new_query = $query) =~ s/X/p$index/g;
    swi_eval($new_query);
}

sub significant {
    my ( $pos_old, $neg_old, $pos_new, $neg_new ) = @_;
    my $pos_ratio_new = $pos_new / ( $pos_new + $neg_new );
    my $pos_ratio_old = $pos_old / ( $pos_old + $neg_old );
    my $p_value       =
      ( $pos_new & $pos_old ) ? log( $pos_ratio_new / $pos_ratio_old ) : 0;
    my $n_value =
      ( $neg_new & $neg_old )
      ? log( ( 1 - $pos_ratio_new ) / ( 1 - $pos_ratio_old ) )
      : 0;
    my $sig = 2 * $pos_new * $p_value + 2 * $neg_new * $n_value;
    $sig > 6.64;
}

sub print_rule {
    my $rule_ref = shift;
	my ($rule, $last_variable, $pos_ref, $neg_ref) = @$rule_ref;
	print sprintf("target(X) :- %s. p: %d n: %d a: %.2f%%\n", $rule, scalar(@$pos_ref), scalar(@$neg_ref), 100 * @$pos_ref / (@$pos_ref + @$neg_ref));
}

#1st set is suppressed by 2nd set
sub suppressed_by {
    my ($this_ref, $that_ref) = @_;
    my ($this_index, $that_index) = (0, 0);
    my $overlap_count = 0;
    while ($this_index < @$this_ref and $that_index < @$that_ref) {
        my ($this_elem, $that_elem) = ($this_ref->[$this_index], $that_ref->[$that_index]);
        if ($this_elem < $that_elem) {
            $this_index++;
        } elsif ($this_elem > $that_elem) {
            $that_index++;
        } else {
            $overlap_count++;
            $this_index++;
            $that_index++;
        }
    }
    $overlap_count > $params{cover_ratio} * @$this_ref;
}

sub can_insert {
    my ($rule_ref, $results_ref) = @_;
    for (@$results_ref) {
        return 0 if get_h_value($_) > get_h_value($rule_ref) and suppressed_by($rule_ref->[2], $_->[2]);
    }
    return @results < $max_rules_cnt or get_h_value($rule_ref) > get_h_value($results[$#results]);
}


sub insert {
    my ($rule_ref, $results_ref) = @_;
    for (@results) {
        if (get_h_value($rule_ref) > get_h_value($_) and suppressed_by($_->[2], $rule_ref->[2])) {
            $_ = undef;
        }
    }

    push @$results_ref, $rule_ref;
    @results = sort { get_h_value($b) <=> get_h_value($a) } grep { defined $_ } @results;
    if (@results > $max_rules_cnt) {
        pop @results;
    }
}

sub hash_to_array {
    my $hash_ref = shift;
    my %orders = (
        url => 1,
        text => 2,
        only => 3,
        target => 4,
        parent => 5,
        child  => 6,
    );
    my $label = $hash_ref->{'DATA'};
    my $array_ref = [$label];
    my @keys = sort {
                        my ($pred_a) = split /:/, $a;
                        my ($pred_b) = split /:/, $b;
                        if ($pred_a ne $pred_b) {
                            return $orders{$pred_a} <=> $orders{$pred_b};
                        }
                        return $a cmp $b; } grep { $_ ne 'DATA' } keys %$hash_ref;
    for my $key (@keys) {
        my $value = $hash_ref->{$key};
        push @$array_ref, &hash_to_array($value);
    }
    return $array_ref;
}

sub get_token {
    my ($ref, $index) = @_;
    my $token;
    if ($index == 0) {
        $token = $ref->[$index];
    }
    else {
        $token = $ref->[$index][0];
    }
    return (split /\s+/, $token)[-1];
}

sub get_h_value {
    my ($rule_ref) = @_;
    my (undef, undef, $pos_ref, $neg_ref) = @$rule_ref;
    return get_h_value_from(scalar(@$pos_ref) + scalar(@$neg_ref), scalar(@$pos_ref));
}

sub get_h_value_from {
    my ($total, $pos) = @_;
    return 0 if $total == 0;
    my $ratio = $pos / $total;
    my $interval = 1.64 * sqrt($ratio * (1 - $ratio) / $total);
    return $ratio > $interval ? $ratio - $interval : 0;
}

sub get_priority {
    my ($pos, $neg) = @_;
    return $pos / @total_pos - $neg / @total_neg;
}
